home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / psheet.lisp < prev    next >
Text File  |  1992-06-01  |  19KB  |  480 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package "CLIO-OPEN")
  23.  
  24. (export '(make-property-sheet
  25.       property-sheet
  26.       property-sheet-area
  27.  
  28.       dialog-accept
  29.       dialog-cancel
  30.       ))
  31.  
  32.  
  33. ;;;----------------------------------------------------------------------------+
  34. ;;;                                                                            |
  35. ;;;                              property-sheet                                |
  36. ;;;                                                                            |
  37. ;;;----------------------------------------------------------------------------+
  38.  
  39. (defcontact property-sheet (core core-wm-shell transient-shell)
  40.   ((previous-pointer-x
  41.                     :type (or null int16)
  42.             :initform nil)
  43.    (previous-pointer-y
  44.                     :type (or null int16)
  45.             :initform nil)
  46.    (control-default :type (or null contact)
  47.             :initform nil))
  48.   
  49.   (:resources                                                            
  50.     (border-width  :initform 1) 
  51.     (property-area :type (or function list) :initform nil)
  52.     (default-control :type (member :accept :cancel) :initform :accept)
  53.     )
  54.   (:documentation "A dialog which presents a set of related values for user editing."))
  55.  
  56.  
  57. ;;;----------------------------------------------------------------------------+
  58. ;;;                                                                            |
  59. ;;;                             Accessors                                      |
  60. ;;;                                                                            |
  61. ;;;----------------------------------------------------------------------------+
  62.  
  63. (defmethod (setf contact-foreground) :after (new-value (self property-sheet))
  64.   (setf (contact-foreground (car (composite-children self))) new-value))
  65. (defmethod property-sheet-area ((self  property-sheet))
  66.   "Returns the property area of the PROPERTY-SHEET."
  67.   (with-slots (children) (first (slot-value self 'children))
  68.     (find :area children :key #'contact-name)))
  69.  
  70.  
  71. (defmethod dialog-default-control ((property-sheet property-sheet))
  72.   (with-slots (control-default) property-sheet
  73.     (contact-name control-default)))
  74.  
  75.  
  76. (defmethod (setf dialog-default-control) (new-value (property-sheet property-sheet))
  77.   (check-type new-value (member :accept :cancel) "one of :ACCEPT or :CANCEL")
  78.   (with-slots (control-default) property-sheet
  79.     (when control-default
  80.       (setf (choice-item-highlight-default-p control-default) nil))
  81.     (setf control-default
  82.       (find new-value (composite-children (first (composite-children property-sheet)))
  83.         :key 'contact-name))
  84.     (setf (choice-item-highlight-default-p control-default) t)
  85.     new-value))
  86.  
  87. (defmethod dialog-accept ((self property-sheet))
  88.   "Invokes :accept callback function and pops down the dialog" 
  89.   (if (callback-p self :accept)
  90.       (apply-callback self :accept)
  91.       (with-slots ((members children)) (property-sheet-area self)
  92.     (dolist (member members)
  93.       (apply-callback member :accept))))
  94.   (with-slots (pinned-p) self
  95.     (unless pinned-p (setf (contact-state self) :withdrawn)))) 
  96.  
  97.  
  98. (defmethod dialog-cancel ((self property-sheet))
  99.   "Invokes :cancel callback function and pops down the dialog."
  100.   (with-slots (pinned-p) self
  101.     (unless pinned-p (setf (contact-state self) :withdrawn))) 
  102.   (if (callback-p self :cancel)
  103.       (apply-callback self :cancel)
  104.       (with-slots ((members children)) (property-sheet-area self)
  105.     (dolist (member members)
  106.       (apply-callback member :cancel))))) 
  107.  
  108. (defmethod shell-mapped ((self property-sheet))
  109.   "Invokes :initialize callback function."
  110.   (let ((footer (find :footer (composite-children
  111.                 (car (composite-children self))) :key 'contact-name)))
  112.     (setf (display-text-source footer) " "))
  113.   (apply-callback self :map)
  114.   (apply-callback-else (self :initialize)
  115.     (with-slots ((members children)) (property-sheet-area self)
  116.       (dolist (member members)
  117.     (apply-callback member :initialize)))))
  118.  
  119. (defmethod (setf contact-state) :after ((new-state (eql :mapped)) (self property-sheet))
  120.   ;; Pointer warping must occur after :map-notify received, in case root-relative
  121.   ;; positions have been changed by window manager redirection.
  122.     (with-slots (previous-pointer-x previous-pointer-y control-default display) self
  123.       (cond ((realized-p self)
  124.       ;; Store position for pointer unwarping later....
  125.          (multiple-value-setq        
  126.            (previous-pointer-x previous-pointer-y) (pointer-position self))
  127.          (warp-pointer
  128.            control-default
  129.            (pixel-round (contact-width control-default)  2)
  130.            (- (contact-height control-default) 2)))
  131.         (t  ;; Ensure realized.
  132.          (update-state display))
  133.         )))
  134.  
  135.  
  136. (defmethod shell-unmapped :before ((self property-sheet))
  137.   (with-slots (previous-pointer-x previous-pointer-y) self
  138.     ;; Unwarp pointer to original position, if necessary.
  139.     (when previous-pointer-x
  140.       (warp-pointer self previous-pointer-x previous-pointer-y))))
  141.  
  142. (defmethod dialog-warn ((self property-sheet) message field)
  143.   "Display a warning for verification error."
  144.   (assert (or (null field) (typep field 'contact)) nil "~s is not a contact." field)
  145.   (let* ((footer (find :footer (composite-children
  146.                  (car (composite-children self))) :key #'contact-name))
  147.      (actual-message (or message "These values cannot be accepted."))
  148.      (tw (text-width (display-text-font footer) actual-message)))
  149.     (if (>= tw (contact-width footer))
  150.     (confirm-p
  151.       :message     actual-message
  152.       :near        (or field (slot-value self 'control-default))
  153.       :parent      self
  154.       :accept-only :on
  155.       )
  156.     (setf (display-text-source footer) actual-message))))
  157.  
  158.  
  159.  
  160. ;;;----------------------------------------------------------------------------+
  161. ;;;                                                                            |
  162. ;;;                          Initialization                                    |
  163. ;;;                                                                            |
  164. ;;;----------------------------------------------------------------------------+
  165.  
  166. (defun make-property-sheet (&rest initargs &key default-control &allow-other-keys)
  167.   "Creates and returns a property-sheet instance."
  168.   (declare (values property-sheet))
  169.   (when default-control
  170.     (assert (symbolp default-control) nil "~s is not a symbol name."))
  171.   (apply #'make-contact 'property-sheet initargs))
  172.  
  173.  
  174. (defmethod initialize-instance :after ((self property-sheet)
  175.                        &key property-area (default-control :accept) &allow-other-keys)
  176.   (multiple-value-bind (area-constructor area-initargs)
  177.       (etypecase property-area
  178.     (null
  179.      (let ((space (ab-height (getf *button-dimensions-by-scale* (contact-scale self)))))
  180.        (values 'make-table 
  181.            `(
  182.              :columns              2
  183.              :column-alignment     :right
  184.              :same-width-in-column :on
  185.              :same-height-in-row   :on
  186.              :horizontal-space     ,space
  187.              :vertical-space       ,space))))
  188.  
  189.     (function property-area)
  190.  
  191.     (list (values (first property-area) (rest property-area))))
  192.     
  193.     (with-slots (width height) self
  194.  
  195.       ;; Create the manager
  196.       (let ((manager (make-contact 'property-sheet-manager
  197.                    :name :manager
  198.                    :parent self
  199.                    :x 0 :y 0
  200.                    :width width :height height
  201.                    :border-width 0)))
  202.     
  203.     ;; Create the property area
  204.     (assert (typep (apply area-constructor
  205.                   :name :area
  206.                   :parent manager
  207.                   :x 0 :y 0
  208.                   :width width :height height
  209.                   :border-width 0
  210.                   area-initargs)
  211.                'composite) nil
  212.         "Property area is not a composite." )
  213.     
  214.     (labels
  215.       ((verify      (property-sheet)
  216.             (multiple-value-bind (verified-p message field)
  217.                 (or (not (callback-p property-sheet :verify))
  218.                 (apply-callback property-sheet :verify))
  219.               (if verified-p
  220.                   (dialog-accept property-sheet)    
  221.                   (dialog-warn property-sheet message field))))
  222.        (menu-accept (property-sheet)
  223.             (verify property-sheet)
  224.             (throw :menu nil))
  225.        (menu-cancel (property-sheet)
  226.             (dialog-cancel property-sheet)
  227.             (throw :menu nil)))
  228.       
  229.       ;; Create buttons for command area
  230.       (add-callback (make-action-button :parent manager :name :accept :label "Apply")
  231.               :release #'verify self)
  232.       (add-callback (make-action-button :parent manager :name :cancel :label "Reset")
  233.             :release #'dialog-cancel self)
  234.  
  235.  
  236.       ;; Create footer area - display-text-field
  237.       (make-display-text-field :parent manager :name :footer :alignment :left
  238.                    :display-gravity :west)
  239.       
  240.       ;; Create settings menu
  241.       (let ((choice (menu-choice (make-menu :parent self :title "Settings"))))
  242.         (add-callback (make-action-item :parent choice :name :accept :label "Apply")
  243.               :release #'menu-accept self)
  244.         (add-callback (make-action-item :parent choice :name :cancel :label "Reset")
  245.               :release #'menu-cancel self))
  246.       
  247.       ;; Set default control
  248.       (setf (dialog-default-control self) default-control))))))
  249.  
  250.   
  251.  
  252.  
  253.  
  254. ;;;----------------------------------------------------------------------------+
  255. ;;;                                                                            |
  256. ;;;                          property-sheet-manager                            |
  257. ;;;                                                                            |
  258. ;;;----------------------------------------------------------------------------+
  259.  
  260.  
  261. (defcontact property-sheet-manager (core composite)
  262.   ((compress-exposures :initform :on))
  263.   (:resources
  264.     (event-mask :initform #.(make-event-mask :exposure)))
  265.   (:documentation "The geometry manager for property sheet component areas."))
  266.  
  267.  
  268.  
  269. (defmethod change-layout ((self property-sheet-manager) &optional newly-managed)
  270.   (declare (ignore newly-managed))
  271.   (with-slots (width height parent) self
  272.     
  273.     ;; Ensure big enough for property area if possible.
  274.     (multiple-value-bind (pw ph) (preferred-size self)
  275.       
  276.       ;; Let window mgr know new preferred minimum height.
  277.       (with-wm-properties (parent)
  278.     (setf (wm-min-width  parent) pw
  279.           (wm-min-height parent) ph))
  280.           
  281.       (let ((rw (when (< width pw) pw))
  282.         (rh (when (< height ph) ph)))
  283.     
  284.     (when
  285.       (or
  286.         ;; Don't need to request larger size?
  287.         (not (or rw rh))
  288.         
  289.         ;; Request for larger size rejected?
  290.         (multiple-value-bind (approved-p nx ny nw nh)
  291.         (change-geometry self :width rw :height rh :accept-p t)
  292.           (declare (ignore nx ny))
  293.           (and (not approved-p) (eql nw width) (eql nh height))))
  294.  
  295.       ;; Yes, adjust child layout for current size.
  296.       (adjust-layout self))))))
  297.  
  298.  
  299. (defmethod adjust-layout ((psm property-sheet-manager))
  300.   (with-slots (width height children) psm
  301.     (let*
  302.       ((space         (point-pixels
  303.             (contact-screen psm)
  304.             (getf *dialog-point-spacing*
  305.                   (contact-scale (contact-parent psm)))))
  306.        
  307.        (accept-button (find :accept children :key #'contact-name))
  308.        (abw           (contact-border-width accept-button))
  309.        (awidth        (+ abw abw (contact-width accept-button)))
  310.        (aheight       (+ abw abw (contact-height accept-button)))
  311.        
  312.        (cancel-button (find :cancel children :key #'contact-name))
  313.        (cbw           (contact-border-width cancel-button))
  314.        (cwidth        (+ cbw cbw (contact-width cancel-button)))
  315.        (cheight       (+ cbw cbw (contact-height cancel-button)))
  316.        
  317.        (property-area (find :area children :key #'contact-name))
  318.        
  319.        (footer        (find :footer children :key #'contact-name))
  320.        (footer-height (contact-height footer))
  321.        (button-y      (- height (+ (max aheight cheight) space  footer-height 1)))
  322.        (button-x      (pixel-round (- width (+ awidth cwidth space 1)) 2)))
  323.       
  324.       ;; Adjust footer geometry.
  325.       (resize footer width footer-height (contact-border-width footer))
  326.       (move footer 0 (- height footer-height))
  327.       
  328.       ;; Adjust button geometry.  Make their top edges align.
  329.       (move accept-button button-x button-y)
  330.       (move cancel-button (+ button-x (+ awidth space)) button-y)
  331.       
  332.       ;; Adjust property-area geometry: preferred size if possible, but
  333.       ;; no more than available space.
  334.       (multiple-value-bind (pw ph) (preferred-size property-area :width 0 :height 0)
  335.     (let ((paw (min (max 1 (- width space space)) pw))
  336.           (pah (min (max 1 (- height space space)) ph)))
  337.       (resize property-area paw pah 0)
  338.       
  339.       ;;Center property-area within available space.
  340.       (move property-area
  341.         (max space (pixel-round (- width paw) 2))
  342.         (max space (pixel-round (- button-y pah) 2))))))))
  343.  
  344.  
  345.  
  346. (defmethod display ((manager property-sheet-manager) &optional x y width height &key)
  347.   (declare (ignore x y height width))
  348.   (with-slots (width height children foreground) manager
  349.     (let ((footer (find :footer children :key 'contact-name)))
  350.       (using-gcontext (gcontext :drawable manager :background (contact-current-background-pixel manager)
  351.                 :foreground foreground :subwindow-mode :include-inferiors)
  352.     (draw-rectangle manager gcontext 0 0
  353.             (max 1 (- width 1))
  354.             (max 1 (- height (contact-height footer) 1))
  355.             )
  356.     ))))
  357.  
  358.  
  359. (defmethod rescale :after ((contact property-sheet))
  360.   (when (realized-p contact)
  361.     (refresh contact)))
  362.  
  363. ;;;
  364. ;;;  When the Property Area or one of the Buttons wants to change its geometry we must let it.
  365. ;;;  A change in scale will change the sizes of our children.
  366. ;;;
  367.  
  368. (defmethod manage-geometry ((self property-sheet-manager) (child contact)
  369.                 x y width height border-width &key)
  370.   (let (success-p)
  371.     (if (or 
  372.       
  373.       (and width  (> width  (contact-width child)))
  374.       (and height (> height (contact-height child)))
  375.       )
  376.     (setf success-p #'(lambda (self)
  377.                 (multiple-value-bind (p-w p-h p-b-w)
  378.                 (preferred-size self)
  379.                   (cond ((and width   (< (contact-width self) p-w))
  380.                      (change-geometry self
  381.                            :width  p-w
  382.                            :border-width p-b-w
  383.                            :accept-p t))
  384.                     ((and height (< (contact-height self) p-h))
  385.                      (change-geometry self
  386.                            :height p-h
  387.                            :border-width p-b-w
  388.                            :accept-p t))
  389.                     (t (change-layout self))))))
  390.     ;; else...
  391.     (setf success-p t))
  392.     
  393.     (values success-p
  394.         (or x (contact-x child))
  395.         (or y (contact-y child))
  396.         (or width (contact-width child))
  397.         (or height (contact-height child))
  398.         (or border-width (contact-border-width child)))))
  399.  
  400. (defmethod preferred-size ((self property-sheet-manager) &key width height border-width)
  401.   (declare (ignore width height border-width))
  402.   (with-slots (children) self
  403.     (let* ((accumulated-width 0)
  404.        (highest 0)
  405.        (area (find :area children :key #'contact-name))
  406.        (FOOTER (FIND :FOOTER CHILDREN :KEY #'CONTACT-NAME))
  407.        (buttons (REMOVE FOOTER (remove area children)))
  408.        (screen (contact-screen self))
  409.        (scale  (contact-scale (contact-parent self)))
  410.        (pixel (getf *dialog-point-spacing* scale))
  411.        (hspace (point-pixels screen pixel :horizontal))
  412.        (vspace (point-pixels screen pixel :vertical)))
  413.  
  414.       ;;Find out how much space the buttons will need.
  415.       ;;Remember: buttons are in a row, so we're interested in combined width
  416.       ;;          and the maximum height
  417.       (multiple-value-bind (pwidth1 pheight1 pbw1)
  418.       (preferred-size (first buttons))
  419.     (multiple-value-bind (pwidth2 pheight2 pbw2)
  420.         (preferred-size (second buttons))
  421.       (setf accumulated-width (+ pwidth1 pbw1 pbw1 hspace pwidth2 pbw2 pbw2)
  422.         highest (max (+ pheight1 pbw1 pbw1) (+ pheight2 pbw2 pbw2)))))
  423.       
  424.       ;;We can ignore the preferred border-width because property-sheet-manager
  425.       ;;geometry management forces a zero-width border.
  426.       (multiple-value-bind (pwidth pheight)
  427.       (preferred-size area :width 0 :height 0)
  428.     (MULTIPLE-VALUE-BIND (f-pwidth F-PHEIGHT)
  429.         (PREFERRED-SIZE FOOTER)
  430.       (declare (ignore f-pwidth))
  431.       (values (+ (max pwidth accumulated-width) hspace hspace 2)
  432.           (+ pheight highest F-PHEIGHT vspace vspace vspace 2) ;; add two for rectangle
  433.           0))))))                                           ;; drawn around property-area
  434.  
  435.  
  436. (defmethod resize :after ((self property-sheet-manager) width height border-width)
  437.   (declare (ignore width height border-width))
  438.   (adjust-layout self))
  439.  
  440.  
  441.  
  442.  
  443.  
  444. ;;;----------------------------------------------------------------------------+
  445. ;;;                                                                            |
  446. ;;;                                  Actions                                   |
  447. ;;;                                                                            |
  448. ;;;----------------------------------------------------------------------------+
  449.  
  450. (defevent property-sheet-manager :enter-notify property-sheet-forget-warp)
  451.  
  452. (defevent property-sheet (:button-press :button-3) property-sheet-display-menu)
  453.  
  454. (defun property-sheet-forget-warp (property-sheet-manager)
  455.   (with-slots (parent) (the property-sheet-manager property-sheet-manager)
  456.     (with-slots (previous-pointer-x) (the property-sheet parent)
  457.       (with-event (kind)
  458.     ;; Entering from a child? The first time this happens the child must be
  459.     ;; the default control. Open Look GUI thus dictates that pointer will not
  460.     ;; warp to original position after exiting the property-sheet
  461.     (when (eq kind :inferior)
  462.       (setf previous-pointer-x nil))))))
  463.  
  464. (defun property-sheet-display-menu (property-sheet)
  465.   (let ((menu    (first (composite-shells property-sheet)))
  466.     (display (contact-display property-sheet)))
  467.     
  468.     ;; Pop up settings menu
  469.     (present-dialog menu :button :button-3 :state (with-event (state) state))
  470.     
  471.     (catch :menu
  472.       (loop (process-next-event display)))
  473.     
  474.     ;; Pop down settings menu
  475.     (setf (contact-state menu) :withdrawn)))
  476.  
  477.  
  478.  
  479.  
  480.